home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
COMPNENT
/
ISAMEXPT
/
ISAMEXPT.ZIP
/
ISAM2DBF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-05
|
5KB
|
161 lines
unit Isam2dbf;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, Isamtabl, Gauges, DB, DBTables, ExtCtrls,
U_DbTool, Grids, DBGrids;
type
DBASEExportProc = Procedure(var DATA; DBTable: TTable; ISTable: TIsamTable);
TTransferDlg = class(TForm)
CancelBtn: TBitBtn;
Bevel1: TBevel;
Table1: TTable;
Gauge1: TGauge;
IsamTable1: TIsamTable;
StartBttn: TBitBtn;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure StartBttnClick(Sender: TObject);
private
{ Private declarations }
public
StruGetProc : Structure_GetProc;
FieldGetProc: DBASEExportProc;
Data,Dup : Pointer;
end;
var
TransferDlg: TTransferDlg;
Procedure Isam2DBase(aParent: TForm;
IsamTable: TIsamTable;
DBASETableName: String;
AliasName: String;
Stru_Get: Structure_GetProc;
FieldGet: DBASEExportProc);
implementation
Uses SysUtils, UToolDll, Filer;
{$R *.DFM}
Procedure Isam2DBase(aParent: TForm;
IsamTable: TIsamTable;
DBASETableName: String;
AliasName: String;
Stru_Get: Structure_GetProc;
FieldGet: DBASEExportProc);
var AktDir: String;
begin
if Pos('.',DBaseTableName) > 0 then DBaseTableName:= Copy(DBaseTableName,1,Pos('.',DBaseTableName)-1);
DBaseTableName:= DBaseTableName + '.DBF';
AktDir:= ExtractFilePath(Application.ExeName);
Check_Alias(AliasName,AktDir);
TransferDlg:= TTransferDlg.Create(aParent);
Try
TransferDlg.IsamTable1:= IsamTable;
TransferDlg.Table1.DataBaseName:= AliasName;
TransferDlg.Table1.TableName:= DBaseTableName;
TransferDlg.StruGetProc:= Stru_Get;
TransferDlg.FieldGetProc:= FieldGet;
TransferDlg.ShowModal;
Finally
TransferDlg.Free;
end;
end;
procedure TTransferDlg.FormDestroy(Sender: TObject);
begin
FreeMem(Data,IsamTable1.RecSize);
FreeMem(Dup,IsamTable1.RecSize);
if Table1.Active then Table1.Close;
end;
procedure TTransferDlg.FormCreate(Sender: TObject);
begin
StruGetProc:= NIL;
FieldGetProc:= NIL;
if Sprache = 1 then CancelBtn.Caption:= 'End';
end;
procedure TTransferDlg.FormShow(Sender: TObject);
begin
Erzeuge_Tabelle(Self,
Table1.DataBaseName,
Table1.TableName,
StruGetProc);
Table1.Open;
if Table1.Active then begin
if Table1.RecordCount > 0 then begin
if Sprache = 1 then begin
if JaNein('DBASE-Tabelle already contains data','delete data ?') then begin
Table1.Close;
Table1.EmptyTable;
Table1.Open;
end;
end
else begin
if JaNein('DBASE-Tabelle enthΣlt bereits Daten','Daten l÷schen ?') then begin
Table1.Close;
Table1.EmptyTable;
Table1.Open;
end;
end;
end;
end
else begin
if Sprache = 1 then Errorwindow('Table could not be opened','')
else Errorwindow('Tabelle konnte nicht erzeugt werden','');
end;
GetMem(Data,IsamTable1.RecSize);
GetMem(Dup,IsamTable1.RecSize);
end;
procedure TTransferDlg.StartBttnClick(Sender: TObject);
var i,RCount: Longint;
Altprogress,NeuProgress: Integer;
begin
if Table1.Active then begin
if IsamTable1.Active then begin
RCount:= IsamTAble1.RecordCount;
IsamTable1.First(DATA^,DUP^);
i:= 0;
AltProgress:= 0;
DBGrid1.Hide;
Repeat
IsamTable1.Get(DATA^,DUP^);
if IsamOk then begin
Table1.Append;
FieldGetProc(DATA^,Table1,IsamTable1);
Table1.Post;
IsamTable1.Next(DATA^,DUP^);
end;
Inc(i);
NeuProgress:= Round((i/RCount)*100);
if AltProgress <> NeuProgress then begin
AltProgress:= NeuProgress;
Gauge1.Progress:= NeuProgress;
end;
Until (IsamOk = False) or (i = rCount);
DbGrid1.Show;
end
else begin
if Sprache = 1 then Errorwindow('Isamtable is not opened','')
else Errorwindow('Isamtabelle ist nicht ge÷ffnet','');
end;
end
else begin
if Sprache = 1 then Errorwindow('DBASE-table is not opened','')
else Errorwindow('DBASE-Tabelle ist nicht ge÷ffnet','');
end;
end;
end.